home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / number.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-07-21  |  30.8 KB  |  1,233 lines
  1. /*
  2.  *
  3.  * n u m b e r . c                -- Numbers management
  4.  *
  5.  *
  6.  * Numbers recognized by the interpreter are:
  7.  *        - integer (which fit in a C long)
  8.  *        - bignum  (arbitrary precision integer)
  9.  *        - flonum  (represented as a C double)
  10.  *
  11.  * Bignum use the GNU gmp API. However to avoid to fall under the GPL terms
  12.  * you can use the FGMP package (FGMP is a public domain implementation of
  13.  * a subset of the GNU gmp library with the same API, written by Mark 
  14.  * Henderson <markh@wimsey.bc.ca>). If your concern is speed, and if the
  15.  * GPL is not a problem for you, use the gmp package. 
  16.  *
  17.  *
  18.  *****
  19.  *
  20.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  21.  * 
  22.  *
  23.  * Permission to use, copy, and/or distribute this software and its
  24.  * documentation for any purpose and without fee is hereby granted, provided
  25.  * that both the above copyright notice and this permission notice appear in
  26.  * all copies and derived works.  Fees for distribution or use of this
  27.  * software or derived works may only be charged with express written
  28.  * permission of the copyright holder.  
  29.  * This software is provided ``as is'' without express or implied warranty.
  30.  *
  31.  * This software is a derivative work of other copyrighted softwares; the
  32.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  33.  *
  34.  *
  35.  *           Author: Erick Gallesio [eg@kaolin.unice.fr]
  36.  *    Creation date: 12-May-1993 10:34
  37.  * Last file update: 21-Jul-1996 18:48
  38.  */
  39.  
  40. #include "stk.h"
  41.  
  42. #define SMALLNUMP(x)    (fabs(x) <= SMALLINT_MAX)
  43. #define ISINT(x)    (floor(x) == (x))
  44.  
  45.  
  46. static double do_compare(SCM x, SCM y);
  47.  
  48.  
  49. static SCM makesmallint(long x)
  50. {
  51.   SCM z;
  52.  
  53. #ifndef COMPACT_SMALL_CST
  54.   NEWCELL(z, tc_integer);
  55. #endif
  56.   SET_INTEGER(z, x); 
  57.   return z;
  58. }
  59.  
  60. static SCM makebignum(char *s)
  61. {
  62.   SCM z;
  63.   NEWCELL(z, tc_bignum); 
  64.   BIGNUM(z) = must_malloc(sizeof(MP_INT));
  65.   mpz_init_set_str(BIGNUM(z), s, 10);
  66.   return z;
  67. }
  68.  
  69.  
  70. /******************************************************************************
  71.  * 
  72.  * Conversion Functions 
  73.  *
  74.  ******************************************************************************/
  75.  
  76. static int digitp(char c, int base)
  77. {
  78.   c = ('0' <= c && c <= '9') ? c - '0':
  79.       ('a' <= c && c <= 'f') ? c - 'a' + 10:
  80.       ('A' <= c && c <= 'F') ? c - 'A' + 10:
  81.       (c == '#')             ? 0      :
  82.       100;
  83.   return (c < base);
  84. }
  85.  
  86. static SCM int2bignum(long n)
  87. {
  88.   SCM z;
  89.   NEWCELL(z, tc_bignum);
  90.   BIGNUM(z) = must_malloc(sizeof(MP_INT));
  91.   mpz_init_set_si(BIGNUM(z), n);
  92.   return z;
  93. }
  94.  
  95. static double bignum2double(MP_INT *bn)
  96. {
  97.   char   *s= mpz_get_str(NULL, 10, bn);
  98.   double d = (double) atof(s);
  99.   
  100.   free(s);
  101.   return d;
  102. }
  103.  
  104. static SCM double2integer(double n)    /* small or big depending of n's size */
  105. {
  106.   int i, j, size = 20;
  107.   char *tmp = NULL;
  108.   SCM z;
  109.  
  110.   if (!ISINT(n)) Err("cannot convert this number to an integer", STk_makenumber(n));
  111.   
  112.   /* Try first to convert n to a long */
  113.   if (((double) SMALLINT_MIN <= n) && (n <= (double) SMALLINT_MAX))
  114.     return STk_makeinteger((long) n);
  115.  
  116.   /* n doesn't fit in a long => build a bignum. THIS IS VERY INEFFICIENT */  
  117.   tmp = must_malloc(size);
  118.   i = 0;
  119.   if (n < 0.0) { tmp[i++] = '-'; n = -n; }
  120.   do {
  121.     if (i >= size) tmp = must_realloc(tmp, size *= 2);
  122.     tmp[i++] = (int) fmod(n, (double) 10) + '0';
  123.     n = floor(n / 10.0);
  124.   }
  125.   while (n > 0.0);
  126.   tmp[i] = 0;
  127.  
  128.   /* Reverse the content of string tmp */
  129.   for (i=i-1, j=(tmp[0]=='-'); i > j; i--, j++) {
  130.     char c = tmp[i];
  131.     tmp[i] = tmp[j];
  132.     tmp[j] = c;
  133.   }
  134.  
  135.   /* tmp contains a textual representation of n. Convert it to a bignum */
  136.   z = makebignum(tmp);
  137.   if (tmp) free(tmp);
  138.   return z;
  139. }
  140.  
  141.  
  142.  
  143. /* Convert a number to a C-string. Result must be freed if != from buffer */
  144. char *STk_number2Cstr(SCM n, long base, char buffer[])
  145. {
  146.   char *s = buffer;
  147.   
  148.   switch (TYPE(n)) {
  149.     case tc_flonum:
  150.          if (base != 10) Err("base must be 10 for this number", n);
  151.          sprintf(buffer, "%.15g", FLONM(n));
  152.          if (strchr(buffer, '.') == NULL && strchr(buffer, 'e') == NULL) 
  153.        strcat(buffer, ".0");
  154.      return buffer;
  155.     case tc_integer:
  156.      {
  157.        long tmp, val = INTEGER(n);
  158.        int u;
  159.  
  160.        if (base==2 || base==8 || base==10 || base==16) {
  161.          if (val < 0) {
  162.            val  = -val;
  163.            *s++ = '-';
  164.          }
  165.          for (s++, tmp=val; tmp >= base; tmp /= base) s++;
  166.          *s = '\000'; tmp = val;
  167.          do {
  168.            u = tmp % base;
  169.            *(--s) = u + ((u < 10) ? '0' : 'a'-10);
  170.            tmp   /= base;
  171.          }
  172.          while (tmp);
  173.          return buffer;
  174.        }
  175.      }
  176.     case tc_bignum:
  177.        if (base==2 || base==8 || base==10 || base==16) {
  178.          s = must_malloc(mpz_sizeinbase(BIGNUM(n), base) + 2);
  179.          s = mpz_get_str(s, base, BIGNUM(n));
  180.          return s;
  181.        }
  182.   }
  183.  
  184.   Err("base must be 2, 8, 10 or 16", (base == LONG_MIN) ? NIL: makesmallint(base));
  185.   return NULL; /* never reached */
  186. }
  187.  
  188. /* Return #f if the C string doesn't contain a valid number. */
  189. /* UGLY! must be rewritten */
  190. SCM STk_Cstr2number(char *str, long base)
  191. {
  192.   int i, adigit=0, isint=1, exact=' ', radix = 0;
  193.   char *start      = str;
  194.   register char *p = str;
  195.  
  196.   for (i = 0; i < 2; i++) {
  197.     if (*p == '#') {
  198.       p += 1;
  199.       switch (*p++) {
  200.         case 'e': if (exact == ' ') { exact = 'e'; break; }  else return Ntruth;
  201.     case 'i': if (exact == ' ') { exact = 'i'; break; }  else return Ntruth;
  202.     case 'b': if (!radix) {base = 2;  radix = 1; break;} else return Ntruth;
  203.     case 'o': if (!radix) {base = 8;  radix = 1; break;} else return Ntruth;
  204.     case 'd': if (!radix) {base = 10; radix = 1; break;} else return Ntruth;
  205.     case 'x': if (!radix) {base = 16; radix = 1; break;} else return Ntruth;
  206.     default:  Err("bad # syntax", STk_makestring(str));
  207.       }
  208.       str += 2;
  209.     }
  210.     if (*p != '#') break;
  211.   }
  212.  
  213.   if (base != 2 && base != 8 && base != 10 && base != 16)
  214.     Err("base must be 2, 8, 10 or 16", (base==LONG_MIN) ? NIL: makesmallint(base));
  215.   
  216.   if (*p == '-' || *p == '+') p+=1;
  217.   if (*p == '#') goto End;
  218.   while(digitp(*p, base)) { p+=1; adigit=1; if (*p == '#') isint = 0; }
  219.  
  220.   if (*p=='.'){
  221.     isint = 0; p += 1;
  222.     while(digitp(*p, base)) { p+=1; adigit=1; }
  223.   }
  224.  
  225.   if (!adigit) goto End;
  226.  
  227.   if (*p && strchr("eEsSfFdDlL", *p)) {
  228.     isint = 0;
  229.     p += 1;
  230.     if (*p == '-' || *p == '+') p+=1;
  231.     if (!digitp(*p, base)) goto End; 
  232.     p+=1;
  233.     while (digitp(*p, base)) p+=1;
  234.   }
  235.   if (*p) goto End;
  236.  
  237.   /* Now we are sure it is a number. Find the more adequate type */
  238.   if (isint) {
  239.     MP_INT n;
  240.  
  241.     if (*str == '+') str+=1; /* mpz_init_set_str doesn't recognize +xyz !!! */
  242.     if (mpz_init_set_str(&n, str, base) < 0) {
  243.       mpz_clear(&n);
  244.       return Ntruth;
  245.     }
  246.     if (mpz_cmp_si(&n, SMALLINT_MIN) >=0 && mpz_cmp_si(&n, SMALLINT_MAX) <= 0) {
  247.       long num = mpz_get_si(&n);
  248.       mpz_clear(&n);
  249.       return (exact == 'i') ? STk_makenumber(num) : makesmallint(num);
  250.     }
  251.     /* It's a bignum */
  252.     if (exact == 'i') return STk_makenumber(bignum2double(&n));
  253.     else {
  254.       SCM z;
  255.  
  256.       NEWCELL(z, tc_bignum);
  257.       BIGNUM(z) = must_malloc(sizeof(MP_INT));
  258.       mpz_init_set(BIGNUM(z), &n);
  259.       mpz_clear(&n);
  260.       return z;
  261.     }
  262.   }
  263.   
  264.   /* It's a float */
  265.   if (exact == 'e')
  266.     Err("#e cannot be specified on this number", STk_makestring(str));
  267.   if (base == 10) {
  268.     /* Replace sharp signs by 0 */
  269.     for(p=str; *p; p++) 
  270.       switch (*p) {
  271.     case '#': *p = '0'; break;
  272.     case 's': case 'S': case 'f': case 'F':
  273.     case 'd': case 'D': case 'l': case 'L': *p = 'e';
  274.       }
  275.     return STk_makenumber((double) atof(str));
  276.   }
  277. End:
  278.   if (*start ==  '#') Err("Bad # syntax", STk_makestring(start));
  279.   return Ntruth;
  280. }
  281.  
  282. long STk_integer_value(SCM x) /* Returns LONG_MIN if not representable as int */
  283. {
  284.   if (INTEGERP(x)) return INTEGER(x);
  285.   if (BIGNUMP(x)) {
  286.     if (mpz_cmp_si(BIGNUM(x), SMALLINT_MIN)>=0 && 
  287.     mpz_cmp_si(BIGNUM(x), SMALLINT_MAX)<=0)
  288.       return mpz_get_si(BIGNUM(x));
  289.   }
  290.   return LONG_MIN;
  291. }
  292.  
  293. long STk_integer_value_no_overflow(SCM x) /* Returns LONG_MIN if not an integer */
  294. {
  295.   if (INTEGERP(x)) return INTEGER(x);
  296.   if (BIGNUMP(x))  return mpz_get_si(BIGNUM(x));
  297.   return LONG_MIN;
  298. }
  299.  
  300. int STk_equal_numbers(SCM number1, SCM number2) /* number1 = number2 */
  301. {
  302.   return do_compare(number1, number2) == 0;
  303. }
  304.  
  305. /******************************************************************************
  306.  *
  307.  * Simple operations 
  308.  *
  309.  ******************************************************************************/
  310.  
  311. static SCM clone(SCM number)
  312. {
  313.   /* clone a number */
  314.   switch (TYPE(number)) {
  315.     case tc_integer: return makesmallint(INTEGER(number));
  316.     case tc_bignum:  {
  317.                      SCM z;
  318.                
  319.                NEWCELL(z, tc_bignum); 
  320.                BIGNUM(z) = must_malloc(sizeof(MP_INT));
  321.                mpz_init(BIGNUM(z));
  322.                mpz_set(BIGNUM(z), BIGNUM(number));
  323.                return z;
  324.              }
  325.     case tc_flonum:  return STk_makenumber(FLONM(number));
  326.     default:         /* This is not a number. Return the parameter unmodified. */
  327.                      return number; /* Error will be signaled later */
  328.   }
  329. }
  330.  
  331. static void do_multiply(SCM *x, SCM y)
  332. {
  333.   switch (TYPE(*x)) {
  334.     case tc_integer:
  335.          switch (TYPE(y)) {
  336.        case tc_integer:
  337.             {
  338.           double prod;
  339.           if (SMALLNUMP(prod=(double) INTEGER(*x) * INTEGER(y)))
  340.             SET_INTEGER(*x, (long) prod);
  341.           else {
  342.             *x = int2bignum(INTEGER(*x));
  343.             mpz_mul_ui(BIGNUM(*x), BIGNUM(*x), INTEGER(y));
  344.           }
  345.         }
  346.         break;
  347.        case tc_bignum:
  348.         *x = int2bignum(INTEGER(*x));
  349.         mpz_mul(BIGNUM(*x), BIGNUM(*x), BIGNUM(y));
  350.         break;
  351.        case tc_flonum:
  352.         *x = STk_makenumber(INTEGER(*x) * FLONM(y));
  353.         break;
  354.      }
  355.      break;
  356.     case tc_bignum:
  357.      switch (TYPE(y)) {
  358.        case tc_integer: 
  359.             {
  360.           SCM tmp = int2bignum(INTEGER(y));
  361.           mpz_mul(BIGNUM(*x), BIGNUM(*x), BIGNUM(tmp));
  362.         }
  363.         break;
  364.        case tc_bignum:
  365.         mpz_mul(BIGNUM(*x), BIGNUM(*x),  BIGNUM(y));
  366.         break;
  367.        case tc_flonum:
  368.         *x = STk_makenumber(bignum2double(BIGNUM(*x)) * FLONM(y));
  369.         break;
  370.      }
  371.      break;
  372.     case tc_flonum:
  373.      switch (TYPE(y)) {
  374.        case tc_integer:
  375.             FLONM(*x) *= INTEGER(y);
  376.         break;
  377.        case tc_bignum:
  378.         FLONM(*x) *= bignum2double(BIGNUM(y));
  379.         break;
  380.        case tc_flonum:
  381.         FLONM(*x) *= FLONM(y);
  382.         break;
  383.      }
  384.      break;
  385.   }
  386. }
  387.  
  388. static void do_addition(SCM *x, SCM y)
  389. {
  390.   switch (TYPE(*x)) {
  391.     case tc_integer:
  392.          switch (TYPE(y)) {
  393.        case tc_integer:
  394.             {
  395.           double add;
  396.           if (SMALLNUMP(add=(double) INTEGER(*x) + INTEGER(y)))
  397.             SET_INTEGER(*x, (long) add);
  398.           else {
  399.             *x = int2bignum(INTEGER(*x));
  400.             mpz_add_ui(BIGNUM(*x), BIGNUM(*x), INTEGER(y));
  401.           }
  402.         }
  403.         break;
  404.        case tc_bignum:
  405.         *x = int2bignum(INTEGER(*x));
  406.         mpz_add(BIGNUM(*x), BIGNUM(*x), BIGNUM(y));
  407.         break;
  408.        case tc_flonum:
  409.         *x = STk_makenumber(INTEGER(*x) + FLONM(y));
  410.         break;
  411.      }
  412.      break;
  413.     case tc_bignum:
  414.      switch (TYPE(y)) {
  415.        case tc_integer:
  416.           {
  417.             SCM tmp = int2bignum(INTEGER(y));
  418.         mpz_add(BIGNUM(*x), BIGNUM(*x), BIGNUM(tmp));
  419.           }
  420.           break;
  421.        case tc_bignum:
  422.         mpz_add(BIGNUM(*x), BIGNUM(*x),  BIGNUM(y));
  423.         break;
  424.        case tc_flonum:
  425.         *x = STk_makenumber(bignum2double(BIGNUM(*x)) + FLONM(y));
  426.         break;
  427.      }
  428.      break;
  429.     case tc_flonum:
  430.      switch (TYPE(y)) {
  431.        case tc_integer:
  432.             FLONM(*x) += INTEGER(y);
  433.         break;
  434.        case tc_bignum:
  435.         FLONM(*x) += bignum2double(BIGNUM(y));
  436.         break;
  437.        case tc_flonum:
  438.         FLONM(*x) += FLONM(y);
  439.         break;
  440.      }
  441.      break;
  442.   }
  443. }
  444.  
  445. static void do_substract(SCM *x, SCM y)
  446. {
  447.   switch (TYPE(*x)) {
  448.     case tc_integer:
  449.          switch (TYPE(y)) {
  450.        case tc_integer:
  451.             {
  452.           double add;
  453.           if (SMALLNUMP(add=(double) INTEGER(*x) - INTEGER(y)))
  454.             SET_INTEGER(*x,(long) add);
  455.           else {
  456.             *x = int2bignum(INTEGER(*x));
  457.             mpz_sub_ui(BIGNUM(*x), BIGNUM(*x), INTEGER(y));
  458.           }
  459.         }
  460.         break;
  461.        case tc_bignum:
  462.         *x = int2bignum(INTEGER(*x));
  463.         mpz_sub(BIGNUM(*x), BIGNUM(*x), BIGNUM(y));
  464.         break;
  465.        case tc_flonum:
  466.         *x = STk_makenumber(INTEGER(*x) - FLONM(y));
  467.         break;
  468.      }
  469.      break;
  470.     case tc_bignum:
  471.      switch (TYPE(y)) {
  472.        case tc_integer:
  473.           {
  474.             SCM tmp = int2bignum(INTEGER(y));
  475.         mpz_sub(BIGNUM(*x), BIGNUM(*x), BIGNUM(tmp));
  476.           }
  477.           break;
  478.        case tc_bignum:
  479.         mpz_sub(BIGNUM(*x), BIGNUM(*x),  BIGNUM(y));
  480.         break;
  481.        case tc_flonum:
  482.         *x = STk_makenumber(bignum2double(BIGNUM(*x)) - FLONM(y));
  483.         break;
  484.      }
  485.      break;
  486.     case tc_flonum:
  487.      switch (TYPE(y)) {
  488.        case tc_integer:
  489.             FLONM(*x) -= INTEGER(y);
  490.         break;
  491.        case tc_bignum:
  492.         FLONM(*x) -= bignum2double(BIGNUM(y));
  493.         break;
  494.        case tc_flonum:
  495.         FLONM(*x) -= FLONM(y);
  496.         break;
  497.      }
  498.      break;
  499.   }
  500. }
  501.  
  502. static void do_divide(SCM *x, SCM y)
  503. {
  504.   switch (TYPE(*x)) {
  505.     case tc_integer:
  506.          switch (TYPE(y)) {
  507.        case tc_integer:
  508.             {
  509.           double div = (double) INTEGER(*x) / INTEGER(y);
  510.          
  511.           if (ISINT(div))
  512.             SET_INTEGER(*x, (double) div);
  513.           else
  514.             *x = STk_makenumber(div);
  515.         }
  516.         break;
  517.        case tc_bignum:
  518.         {
  519.           MP_INT q,  r;
  520.  
  521.           mpz_init(&q); mpz_init(&r);
  522.           *x = int2bignum(INTEGER(*x));
  523.           mpz_mdivmod(&q, &r, BIGNUM(*x), BIGNUM(y));
  524.           if (mpz_cmp_ui(&r, 0L) == 0)
  525.             mpz_set(BIGNUM(*x), &q);
  526.           else
  527.             *x=STk_makenumber(bignum2double(BIGNUM(*x)) /
  528.                       bignum2double(BIGNUM(y)));
  529.           mpz_clear(&q); mpz_clear(&r);
  530.         }
  531.         break;
  532.        case tc_flonum:
  533.         *x = STk_makenumber(INTEGER(*x) / FLONM(y));
  534.         break;
  535.      }
  536.      break;
  537.     case tc_bignum:
  538.      switch (TYPE(y)) {
  539.        case tc_integer:
  540.        case tc_bignum:
  541.           {
  542.         MP_INT q,  r;    
  543.  
  544.         mpz_init(&q); mpz_init(&r);
  545.         if (INTEGERP(y)) 
  546.           y = int2bignum(INTEGER(y));
  547.  
  548.         mpz_mdivmod(&q, &r, BIGNUM(*x), BIGNUM(y));
  549.         if (mpz_cmp_ui(&r, 0L) == 0)
  550.           mpz_set(BIGNUM(*x), &q);
  551.         else
  552.           *x=STk_makenumber(bignum2double(BIGNUM(*x)) /
  553.                     bignum2double(BIGNUM(y)));
  554.         mpz_clear(&q); mpz_clear(&r);
  555.           }
  556.           break;
  557.        case tc_flonum:
  558.         *x = STk_makenumber(bignum2double(BIGNUM(*x)) / FLONM(y));
  559.         break;
  560.      }
  561.      break;
  562.     case tc_flonum:
  563.      switch (TYPE(y)) {
  564.        case tc_integer:
  565.             FLONM(*x) /= INTEGER(y);
  566.         break;
  567.        case tc_bignum:
  568.         FLONM(*x) /= bignum2double(BIGNUM(y));
  569.         break;
  570.        case tc_flonum:
  571.         FLONM(*x) /= FLONM(y);
  572.         break;
  573.      }
  574.      break;
  575.   }
  576. }
  577.  
  578. static SCM do_integer_division(SCM x, SCM y, int quotientp)
  579. {
  580.   MP_INT q, r;
  581.   SCM res;
  582.   int exact = 1;
  583.  
  584.   /* Divide x by y and return its quotient or remainder. y is not 0 */
  585.   if (FLONUMP(x))
  586.     if (ISINT(FLONM(x))) { x = double2integer(FLONM(x)); exact = 0; }
  587.     else Err("bad number in an integer division", x);
  588.   
  589.   if (FLONUMP(y))
  590.     if (ISINT(FLONM(y))) { y = double2integer(FLONM(y)); exact = 0; }
  591.     else Err("bad number in an integer division", y);
  592.   
  593.   /* Here, x and y can only be integer or bignum (not float) */
  594.   if (INTEGERP(x))
  595.     if (INTEGERP(y)) {
  596.       res = makesmallint(quotientp? INTEGER(x)/INTEGER(y):
  597.                        INTEGER(x)%INTEGER(y));
  598.       return exact? res : STk_exact2inexact(res);
  599.     }
  600.     else
  601.       x = int2bignum(INTEGER(x));
  602.   else {
  603.     /* x is a bignum */
  604.     if (INTEGERP(y))
  605.       y = int2bignum(INTEGER(y));
  606.   }
  607.   
  608.   /* x and y are both bignums */
  609.   res = makebignum("0");
  610.  
  611.   mpz_init(&q); mpz_init(&r);
  612.   mpz_divmod(&q, &r, BIGNUM(x), BIGNUM(y)); /* use divmod instead of mdivmod */
  613.   mpz_set(BIGNUM(res), quotientp? &q : &r); /* Thanks to kerch@parc.xerox.com*/
  614.   mpz_clear(&q); mpz_clear(&r);
  615.   return exact? res : STk_exact2inexact(res);
  616. }
  617.  
  618. static double do_compare(SCM x, SCM y)
  619. {
  620.   switch (TYPE(x)) {
  621.     case tc_integer:
  622.          switch (TYPE(y)) {
  623.        case tc_integer: return (double) (INTEGER(x)-INTEGER(y));
  624.        case tc_bignum:  return (double) -(mpz_cmp_si(BIGNUM(y), INTEGER(x)));
  625.        case tc_flonum:  return (double) INTEGER(x) - FLONM(y);
  626.      }
  627.     case tc_bignum:
  628.      switch (TYPE(y)) {
  629.        case tc_integer: return (double) mpz_cmp_si(BIGNUM(x), INTEGER(y));
  630.        case tc_bignum:  return (double) mpz_cmp(BIGNUM(x), BIGNUM(y));
  631.        case tc_flonum:  return bignum2double(BIGNUM(x))-FLONM(y);
  632.      }
  633.     case tc_flonum:
  634.      switch (TYPE(y)) {
  635.        case tc_integer: return (FLONM(x) - (double) INTEGER(y));
  636.        case tc_bignum:  return (FLONM(x) - bignum2double(BIGNUM(y)));
  637.        case tc_flonum:  return (FLONM(x) - FLONM(y));
  638.      }
  639.     default: return 0.0; /* never reached */
  640.   }
  641. }
  642.  
  643.  
  644. /******************************************************************************
  645.  * 
  646.  * Scheme primitives and utilities 
  647.  *
  648.  ******************************************************************************/
  649.  
  650. SCM STk_makenumber(double x)
  651. {
  652.   /* Floats are not stored in a struct obj since this leads to memory consumption
  653.    * This  memory consumption due to alignment problems. 
  654.    * For instance on a Sun 4, where double are 8 bytes, a struct obj with a double
  655.    * in line will occupy 16 bytes whereas it occupies only 12 bytes if the double
  656.    * is mallocated.
  657.    * This change (94/08/29) will give worst performances when crunching numbers,
  658.    * but use Fortran if this is your job :->
  659.    */
  660.  
  661.   SCM z;
  662.   NEWCELL(z,tc_flonum); 
  663.   (*z).storage_as.flonum.data = must_malloc(sizeof(double));
  664.   FLONM(z) = x; 
  665.   return z;
  666. }
  667.  
  668.  
  669. SCM STk_makeinteger(long x)
  670. {
  671.   return (SMALLINT_MIN <= x && x <= SMALLINT_MAX) ? makesmallint(x): int2bignum(x);
  672. }
  673.     
  674.  
  675. /******************************************************************************/
  676.  
  677. /**** Section 6.5 ****/
  678.  
  679. PRIMITIVE STk_numberp(SCM x)
  680. {
  681.   return NUMBERP(x)? Truth : Ntruth;
  682. }
  683.  
  684. PRIMITIVE STk_integerp(SCM x)
  685. {
  686.   switch (TYPE(x)) {
  687.     case tc_integer:
  688.     case tc_bignum: return Truth;
  689.     case tc_flonum: {
  690.                     double val = FLONM(x);
  691.               return (floor(val) == val)? Truth : Ntruth;
  692.             }
  693.     default: return Ntruth;
  694.   }
  695. }
  696.  
  697. PRIMITIVE STk_exactp(SCM x)
  698. {
  699.   if (NNUMBERP(x)) Err("exact?: Bad number", x);
  700.   return EXACTP(x) ? Truth: Ntruth;
  701. }
  702.  
  703. PRIMITIVE STk_inexactp(SCM x)
  704. {
  705.   if (NNUMBERP(x)) Err("inexact?: Bad number", x);
  706.   return NEXACTP(x) ? Truth: Ntruth;
  707. }
  708.  
  709.  
  710. #define Compare(name, operator)                    \
  711. PRIMITIVE name(SCM l, SCM env, int from_eval)            \
  712. {                                \
  713.   register SCM tmp1, tmp2;                    \
  714.                                 \
  715.   if (NCONSP(l)) Err("too few parameters", l);            \
  716.   tmp1 = from_eval? EVALCAR(l): CAR(l);                \
  717.   if (NNUMBERP(tmp1)) goto Error;                \
  718.                                 \
  719.   for (l=CDR(l); NNULLP(l); l=CDR(l),tmp1=tmp2) {        \
  720.     tmp2 = from_eval? EVALCAR(l): CAR(l);            \
  721.     if (NNUMBERP(tmp2)) goto Error;                \
  722.     if (do_compare(tmp1, tmp2) operator 0) return Ntruth;    \
  723.   }                                \
  724.   return Truth;                            \
  725. Error:                                \
  726.   Err("Bad number in a comparison", l);                \
  727.   return UNDEFINED; /* never reached */                \
  728. }
  729.  
  730. Compare(STk_numequal,  !=)
  731. Compare(STk_lessp,     >=)
  732. Compare(STk_greaterp,  <=)
  733. Compare(STk_lessep,    >)
  734. Compare(STk_greaterep, <)
  735.  
  736.  
  737. PRIMITIVE STk_zerop(SCM n)
  738. {
  739.   switch (TYPE(n)) {
  740.     case tc_integer: return (INTEGER(n) == 0)              ? Truth: Ntruth;
  741.     case tc_flonum:  return (FLONM(n) == 0.0)              ? Truth: Ntruth;
  742.     case tc_bignum:  return (mpz_cmp_ui(BIGNUM(n), 0L) == 0) ? Truth: Ntruth;
  743.     default:         Err("zero?: bad number", n); 
  744.              return UNDEFINED; /* never reached */
  745.   }
  746. }
  747.  
  748. PRIMITIVE STk_positivep(SCM n)
  749. {
  750.   switch (TYPE(n)) {
  751.     case tc_integer: return (INTEGER(n) > 0)              ? Truth: Ntruth;
  752.     case tc_flonum:  return (FLONM(n) > 0.0)              ? Truth: Ntruth;
  753.     case tc_bignum:  return (mpz_cmp_ui(BIGNUM(n), 0L) > 0)  ? Truth: Ntruth;
  754.     default:         Err("positive?: bad number", n);
  755.              return UNDEFINED; /* never reached */
  756.   }
  757. }  
  758.  
  759. PRIMITIVE STk_negativep(SCM n)
  760. {
  761.   switch (TYPE(n)) {
  762.     case tc_integer: return (INTEGER(n) < 0)              ? Truth: Ntruth;
  763.     case tc_flonum:  return (FLONM(n) < 0.0)              ? Truth: Ntruth;
  764.     case tc_bignum:  return (mpz_cmp_ui(BIGNUM(n), 0L) < 0)  ? Truth: Ntruth;
  765.     default:         Err("negative?: bad number", n);
  766.              return UNDEFINED; /* never reached */
  767.   }
  768. }
  769.  
  770. PRIMITIVE STk_oddp(SCM n)
  771. {
  772.   MP_INT q, r;
  773.   long res;
  774.  
  775.   switch (TYPE(n)) {
  776.     case tc_integer: return (INTEGER(n)%2)              ? Truth: Ntruth;
  777.     case tc_bignum:  mpz_init(&q), mpz_init(&r);
  778.                    mpz_divmod_ui(&q, &r, BIGNUM(n), 2L);
  779.                    res = mpz_cmp_ui(&r, 0L);
  780.                    mpz_clear(&q); mpz_clear(&r);
  781.                    return (res != 0) ? Truth: Ntruth;
  782.     default:         Err("odd?: bad number", n);
  783.              return UNDEFINED; /* never reached */
  784.   }
  785. }  
  786.  
  787. PRIMITIVE STk_evenp(SCM n)
  788. {
  789.   MP_INT q, r;
  790.   long res;
  791.  
  792.   switch (TYPE(n)) {
  793.     case tc_integer: return (INTEGER(n)%2)              ? Ntruth: Truth;
  794.     case tc_bignum:  mpz_init(&q), mpz_init(&r);
  795.                    mpz_divmod_ui(&q, &r, BIGNUM(n), 2L);
  796.                    res = mpz_cmp_ui(&r, 0L);
  797.                    mpz_clear(&q); mpz_clear(&r);
  798.                    return (res == 0) ? Truth: Ntruth;
  799.     default:         Err("even?: bad number", n);
  800.              return UNDEFINED; /* never reached */
  801.   }
  802. }
  803.  
  804. PRIMITIVE STk_max(SCM l, SCM env, int from_eval)
  805. {
  806.   register SCM tmp, max;
  807.   int inexact;
  808.  
  809.   if (NULLP(l)) Err("max: bad number of arguments", NIL);
  810.  
  811.   tmp = from_eval? EVALCAR(l): CAR(l);
  812.   if (NNUMBERP(tmp)) goto Error;
  813.   inexact = FLONUMP(tmp);
  814.   max = tmp;
  815.   
  816.   for (l=CDR(l); NNULLP(l); l=CDR(l)) {
  817.     tmp = from_eval? EVALCAR(l): CAR(l);
  818.     if (NNUMBERP(tmp)) goto Error;
  819.     inexact |= FLONUMP(tmp);
  820.     if (do_compare(tmp, max) > 0) max = tmp;
  821.   }
  822.   return (inexact && EXACTP(max)) ? STk_exact2inexact(max) : max;
  823. Error:
  824.   Err("max: bad number", tmp);
  825.   return UNDEFINED; /* never reached */
  826. }
  827.  
  828. PRIMITIVE STk_min(SCM l, SCM env, int from_eval)
  829. {
  830.   register SCM tmp, min;
  831.   int inexact;
  832.  
  833.   if (NULLP(l)) Err("min: bad number of arguments", NIL);
  834.  
  835.   tmp = from_eval? EVALCAR(l): CAR(l);
  836.   if (NNUMBERP(tmp)) goto Error;
  837.   inexact = FLONUMP(tmp);
  838.   min = tmp;
  839.   
  840.   for (l=CDR(l); NNULLP(l); l=CDR(l)) {
  841.     tmp = from_eval? EVALCAR(l): CAR(l);
  842.     if (NNUMBERP(tmp)) goto Error;
  843.     inexact |= FLONUMP(tmp);
  844.     if (do_compare(tmp, min) < 0) min = tmp;
  845.   }
  846.   return (inexact && EXACTP(min)) ? STk_exact2inexact(min) : min;
  847. Error:
  848.   Err("min: bad number", tmp);
  849.   return UNDEFINED; /* never reached */
  850. }
  851.  
  852. PRIMITIVE STk_plus(SCM l, SCM env, int from_eval)
  853. {
  854.   SCM tmp, res = makesmallint(0);
  855.   
  856.   for ( ; CONSP(l); l=CDR(l)) {
  857.     tmp = from_eval? EVALCAR(l): CAR(l);
  858.     if (NNUMBERP(tmp)) Err("+: not a number", tmp);
  859.     do_addition(&res, tmp);
  860.   }
  861.   return res;
  862. }
  863.  
  864. PRIMITIVE STk_difference(SCM l, SCM env, int from_eval)
  865. {
  866.   SCM tmp, res;
  867.  
  868.   if (NULLP(l)) Err("-: no argument given", NIL);
  869.   if (NULLP(CDR(l))) l = Cons(makesmallint(0), l);    /* (- x) --> (- 0 x) */
  870.  
  871.   tmp = res = clone(EVALCAR(l));
  872.   if (NNUMBERP(res)) goto Error;
  873.   for (l=CDR(l) ; CONSP(l); l=CDR(l)) {
  874.     tmp = from_eval? EVALCAR(l): CAR(l);
  875.     if (NNUMBERP(tmp)) goto Error;
  876.     do_substract(&res, tmp);
  877.   }
  878.   return res;
  879. Error:
  880.   Err("-: not a number", tmp);
  881.   return UNDEFINED; /* never reached */
  882. }
  883.  
  884. PRIMITIVE STk_times(SCM l, SCM env, int from_eval)
  885. {
  886.   SCM tmp, res = makesmallint(1);
  887.  
  888.   for ( ; CONSP(l); l=CDR(l)) {
  889.     tmp = from_eval? EVALCAR(l): CAR(l);
  890.     if (NNUMBERP(tmp)) Err("*: not a number", tmp);
  891.     do_multiply(&res, tmp);
  892.   }
  893.   return res;
  894. }
  895.  
  896. PRIMITIVE STk_division(SCM l, SCM env, int from_eval)
  897. {
  898.   SCM tmp, res;
  899.  
  900.   if (NULLP(l)) Err("/: no argumenent given", NIL);
  901.   if (NULLP(CDR(l))) l = Cons(makesmallint(1), l);    /* (/ x) --> (/ 1 x) */
  902.   
  903.   tmp = res = clone(EVALCAR(l));
  904.   if (NNUMBERP(res)) goto Error;
  905.   for (l=CDR(l) ; CONSP(l); l=CDR(l)) {
  906.     tmp = from_eval? EVALCAR(l): CAR(l);
  907.     if (NNUMBERP(tmp) || STk_zerop(tmp) == Truth) goto Error;
  908.     do_divide(&res, tmp);
  909.   }
  910.   return res;
  911. Error:
  912.   Err("/: not a valid number", tmp);
  913.   return UNDEFINED; /* never reached */
  914. }
  915.  
  916. PRIMITIVE STk_absolute(SCM x)
  917. {
  918.   switch (TYPE(x)) {
  919.     case tc_integer: return (INTEGER(x) < 0) ? makesmallint(-INTEGER(x)) : x;
  920.     case tc_flonum:  return (FLONM(x) < 0.0) ? STk_makenumber(-FLONM(x)) : x;
  921.     case tc_bignum:  if (mpz_cmp_ui(BIGNUM(x), 0L) < 0) {
  922.                  SCM tmp = clone(x);
  923.             mpz_neg(BIGNUM(tmp), BIGNUM(x));
  924.             return tmp;
  925.               }
  926.                     return x;
  927.     default:         Err("abs: bad number", x);
  928.              return UNDEFINED; /* never reached */
  929.   }
  930. }  
  931.  
  932. PRIMITIVE STk_quotient(SCM n1, SCM n2)
  933. {
  934.   if (NNUMBERP(n1) || NNUMBERP(n2))
  935.     Err("quotient: bad arguments", Cons(n1, n2));
  936.   if (STk_zerop(n2) == Truth) Err("quotient: division by 0", NIL);
  937.       
  938.   return do_integer_division(n1, n2, TRUE);
  939. }
  940.  
  941. PRIMITIVE STk_remainder(SCM n1, SCM n2)
  942. {
  943.   if (NNUMBERP(n1) || NNUMBERP(n2))
  944.     Err("remainder: bad arguments", Cons(n1, n2));
  945.   if (STk_zerop(n2) == Truth) Err("remainder: division by 0", NIL);
  946.  
  947.   return do_integer_division(n1, n2, FALSE);
  948. }
  949.  
  950. PRIMITIVE STk_modulo(SCM n1, SCM n2)
  951. {
  952.   SCM z;
  953.  
  954.   if (NNUMBERP(n1) || NNUMBERP(n2))
  955.     Err("modulo: bad arguments", Cons(n1, n2));
  956.   if (STk_zerop(n2) == Truth) Err("modulo: division by 0", NIL);
  957.  
  958.   z = do_integer_division(n1, n2, FALSE);
  959.   if (STk_negativep(n1) != STk_negativep(n2) && STk_zerop(z) != Truth) 
  960.     /*kerch@parc.xerox.com*/
  961.     do_addition(&z, n2);
  962.   return z;
  963. }
  964.  
  965.  
  966. static SCM gcd2(SCM n1, SCM n2)
  967. {
  968.   return (STk_zerop(n2) == Truth) ? n1 : gcd2(n2, STk_modulo(n1, n2));
  969. }
  970.  
  971. PRIMITIVE STk_gcd(SCM l, SCM env, int from_eval)
  972. {
  973.   register SCM tmp, res;
  974.  
  975.   if (NULLP(l)) return makesmallint(0L);
  976.   
  977.   tmp = EVALCAR(l);
  978.   if (NNUMBERP(tmp)) goto Error;
  979.   res = STk_absolute(tmp);
  980.   
  981.   for (l=CDR(l); NNULLP(l); l=CDR(l)) {
  982.     tmp = from_eval? EVALCAR(l): CAR(l);
  983.     if (NNUMBERP(tmp)) goto Error;
  984.     res = STk_absolute(gcd2(res, tmp));
  985.   }
  986.   return res;
  987. Error:
  988.   Err("gcd: bad number", tmp);
  989.   return UNDEFINED; /* never reached */
  990. }
  991.  
  992. PRIMITIVE STk_lcm(SCM l, SCM env, int from_eval)
  993. {
  994.   SCM tmp, res, gcd;
  995.  
  996.   if (NULLP(l)) return makesmallint(1L);
  997.  
  998.   tmp = EVALCAR(l);
  999.   if (NNUMBERP(tmp)) goto Error;
  1000.   res = STk_absolute(clone(tmp));
  1001.   
  1002.   for (l=CDR(l); NNULLP(l); l=CDR(l)) {
  1003.     tmp=EVALCAR(l);
  1004.     if (NNUMBERP(tmp)) goto Error;
  1005.     if (STk_zerop(tmp)==Truth) return tmp;
  1006.     gcd = gcd2(res, tmp);
  1007.     do_multiply(&res, tmp);
  1008.     do_divide(&res, gcd);
  1009.     res = STk_absolute(res);
  1010.   }
  1011.   return res;
  1012. Error:
  1013.   Err("lcm: bad number", tmp);
  1014.   return UNDEFINED; /* never reached */
  1015. }
  1016.  
  1017. PRIMITIVE STk_floor(SCM x)
  1018. {
  1019.   if (NNUMBERP(x)) Err("floor: bad number", x);
  1020.   if (FLONUMP(x)) return STk_makenumber(floor(FLONM(x)));
  1021.   return x;
  1022. }
  1023.  
  1024. PRIMITIVE STk_ceiling(SCM x)
  1025. {
  1026.   if (NNUMBERP(x)) Err("ceiling: bad number", x);
  1027.   if (FLONUMP(x)) return STk_makenumber(ceil(FLONM(x)));
  1028.   return x;
  1029. }
  1030.  
  1031. PRIMITIVE STk_truncate(SCM x)
  1032. {
  1033.   if (NNUMBERP(x)) Err("truncate: bad number", x);
  1034.   if (FLONUMP(x)) {
  1035.     double d = FLONM(x);
  1036.     return STk_makenumber(d < 0.0 ? ceil(d) : floor(d));
  1037.   }
  1038.   return x;
  1039. }
  1040.  
  1041. PRIMITIVE STk_round(SCM x)
  1042. {
  1043.   if (NNUMBERP(x)) Err("round: bad number", x);
  1044.   if (FLONUMP(x)) {
  1045.     /*  
  1046.      * R4RS states that round must returns the closest integer to x, rounding to
  1047.      * even when x is halfway between two integers (round to even is for consistency
  1048.      * with IEEE standard).
  1049.      * This explains the (too much) complicate computation below
  1050.      */
  1051.     double v           = FLONM(x); 
  1052.     double v_plus_0_5 = v + 0.5;
  1053.     double res        = floor(v_plus_0_5);
  1054.  
  1055.     return STk_makenumber(
  1056.       (v_plus_0_5 == res && v_plus_0_5/2 != floor(v_plus_0_5/2)) ? res-1: res);
  1057.   }
  1058.   return x;
  1059. }
  1060.  
  1061. #if !defined(WIN32) && !defined(__STDC__)
  1062. #  define concat(a,b) a/**/b
  1063. #else
  1064. #  define concat(a,b) a##b
  1065. #endif
  1066.  
  1067. #define transcendental(fct)                                             \
  1068.     PRIMITIVE concat(STk_,fct)(SCM z)                                   \
  1069.     {                                                                   \
  1070.       if (NUMBERP(z))                                                   \
  1071.         return STk_makenumber(fct(FLONM(STk_exact2inexact(z))));        \
  1072.       Err("transcendental function: bad number", z);                    \
  1073.       return UNDEFINED /* never reached */;                             \
  1074.     }
  1075.  
  1076. transcendental(exp)
  1077. transcendental(log)
  1078. transcendental(sin)
  1079. transcendental(cos)
  1080. transcendental(tan)
  1081. transcendental(asin)
  1082. transcendental(acos)
  1083.  
  1084. PRIMITIVE STk_atan(SCM y, SCM x)
  1085. {
  1086.   if (NNUMBERP(y)) Err("atan: bad  number", y);
  1087.  
  1088.   if (x == UNBOUND)
  1089.     return STk_makenumber(atan(FLONM(STk_exact2inexact(y))));
  1090.   else {
  1091.     double fl_x = FLONM(STk_exact2inexact(x));
  1092.     double fl_y = FLONM(STk_exact2inexact(y));
  1093.  
  1094.     /* Make a special case for (atan 0 0) -- in this case return 0 */
  1095.     return STk_makenumber((fl_x == 0 && fl_y == 0) ? 0L : atan2(fl_y, fl_x));
  1096.   }
  1097. }
  1098.  
  1099. PRIMITIVE STk_sqrt(SCM z)
  1100. {
  1101.   switch (TYPE(z)) {
  1102.     case tc_integer: {
  1103.            double d;
  1104.      
  1105.      if (INTEGER(z) < 0) goto Error;
  1106.      d = (double) sqrt((double) INTEGER(z));
  1107.      return ISINT(d) ? makesmallint((long) d): STk_makenumber(d);
  1108.        }
  1109.     case tc_bignum: {
  1110.          MP_INT root, remainder;
  1111.      SCM res;
  1112.  
  1113.      if (mpz_cmp_si(BIGNUM(z), 0L) < 0) goto Error;
  1114.      mpz_init(&root); mpz_init(&remainder);
  1115.      mpz_sqrtrem(&root, &remainder, BIGNUM(z));
  1116.      if (mpz_cmp_si(&remainder, 0L) == 0) {
  1117.        /* Result is an integer */
  1118.        res = makebignum("0");
  1119.        mpz_set(BIGNUM(res), &root);
  1120.      }
  1121.      else {
  1122.        /* Result is a flonum */
  1123.        res = STk_makenumber(bignum2double(&root));
  1124.      }
  1125.      mpz_clear(&root); mpz_clear(&remainder);
  1126.      return res;
  1127.        }
  1128.     case tc_flonum: {
  1129.          if (FLONM(z) < 0.0) goto Error;
  1130.      return STk_makenumber((double) sqrt(FLONM(z)));
  1131.        }
  1132.     default:
  1133.          Err("sqrt: bad number", z);
  1134.   }
  1135. Error:
  1136.   Err("sqrt: number is negative", z);
  1137.   return UNDEFINED; /* never reached */
  1138. }
  1139.  
  1140. /*
  1141.  (define (exact_expt z1 z2)
  1142.   (define (square x) (* x x))
  1143.   (cond ((= z2 0) 1)
  1144.     ((negative? z2) (/ 1 (exact_expt z1 (abs z2))))
  1145.         ((even? z2) (square (exact_expt z1 (/ z2 2))))
  1146.         (else (* z1 (exact_expt z1 (- z2 1))))))
  1147. */
  1148.  
  1149. static SCM exact_expt(SCM z1, SCM z2)
  1150. {
  1151.   SCM res;
  1152.   
  1153.   if (STk_zerop(z2) == Truth) return makesmallint(1);
  1154.   if (STk_negativep(z2) == Truth) { 
  1155.     /* (/ 1 (expt z1 (abs z2) */
  1156.     res = makesmallint(1);
  1157.     do_divide(&res, exact_expt(z1, STk_absolute(z2)));
  1158.     return res;
  1159.   }
  1160.   if (STk_evenp(z2) == Truth) {
  1161.     /* (square (expt z1 (/ z2 2)) */
  1162.     res = clone(z2);
  1163.     do_divide(&res, makesmallint(2));
  1164.     res = exact_expt(z1, res);
  1165.     do_multiply(&res, res);
  1166.     return res;
  1167.   }
  1168.   /* (* (expt z1 (- z2 1)) z1) */
  1169.   res = clone(z2);
  1170.   do_substract(&res, makesmallint(1));
  1171.   res = exact_expt(z1, res);
  1172.   do_multiply(&res, z1);
  1173.   return res;
  1174. }
  1175.  
  1176. PRIMITIVE STk_expt(SCM z1, SCM z2)
  1177. {
  1178.   if (NNUMBERP(z1)) Err("expt: bad number", z1);
  1179.   if (NNUMBERP(z2)) Err("expt: bad number", z2);
  1180.  
  1181.   return (EXACTP(z1) && EXACTP(z2)) ?
  1182.             exact_expt(z1, z2)  :
  1183.         STk_makenumber((double) pow(FLONM(STk_exact2inexact(z1)),
  1184.                         FLONM(STk_exact2inexact(z2))));
  1185. }
  1186.  
  1187. PRIMITIVE STk_exact2inexact(SCM z)
  1188. {
  1189.   switch (TYPE(z)) {
  1190.     case tc_integer: return STk_makenumber((double) INTEGER(z));
  1191.     case tc_bignum:  return STk_makenumber(bignum2double(BIGNUM(z)));
  1192.     case tc_flonum:  return z;
  1193.     default:         Err("exact->inexact: bad number", z);
  1194.              return UNDEFINED; /* never reached */
  1195.   }
  1196. }
  1197.  
  1198. PRIMITIVE STk_inexact2exact(SCM z)
  1199. {
  1200.   switch (TYPE(z)) {
  1201.     case tc_integer: 
  1202.     case tc_bignum:  return z;
  1203.     case tc_flonum:  return double2integer(floor(FLONM(z)+0.5));
  1204.     default:         Err("inexact->exact: bad number", z);
  1205.                    return UNDEFINED; /* never reached */
  1206.   }
  1207. }
  1208.  
  1209.  
  1210. PRIMITIVE STk_string2number(SCM str, SCM base)
  1211. {
  1212.   if (NSTRINGP(str)) Err("string->number: not a string", str);
  1213.   return STk_Cstr2number(CHARS(str), (base==UNBOUND)? 10 : STk_integer_value(base));
  1214. }
  1215.  
  1216. PRIMITIVE STk_number2string(SCM n, SCM base)
  1217. {
  1218.   char *s, buffer[100];
  1219.   SCM z;
  1220.  
  1221.   if (NNUMBERP(n))   Err("number->string: bad number", n);
  1222.   s = STk_number2Cstr(n, (base == UNBOUND)? 10 : STk_integer_value(base), buffer);
  1223.   z = STk_makestring(s);
  1224.   if (s != buffer) free(s);
  1225.   return z;
  1226. }
  1227.  
  1228. PRIMITIVE  STk_bignump(SCM n)
  1229. {
  1230.   return BIGNUMP(n) ? Truth: Ntruth;
  1231. }
  1232.  
  1233.